home *** CD-ROM | disk | FTP | other *** search
/ Your Choice 3 / Your Choice Software Collection 3.iso / prgmming / gamemag4 / acplasma.pas < prev    next >
Pascal/Delphi Source File  |  1994-04-11  |  4KB  |  162 lines
  1. Program Plasma;
  2.  
  3. Uses Crt;
  4.  
  5. Type
  6.   RGB = Record
  7.     R, G, B  : Byte;
  8.   End;
  9.   Palette = Array[0..255] of RGB; { Structure to hold 768 byte palette }
  10.  
  11. Var
  12.   XRes,              { X Resolution of the screen, make as big as necessary }
  13.   YRes : Integer;    { Y Resolution of the screen, make as big as necessary }
  14.   D    : Palette;    { Palette used in program                              }
  15.  
  16.  
  17. Procedure SetPalette(Var c : Palette);
  18. { Sets the palette, Really? }
  19.  
  20. Var
  21.   x : Byte;
  22.  
  23. Begin
  24.   For x := 0 to 255 do
  25.     Begin
  26.       Port[$3C8] := x;           { Set the DAC register for proper color }
  27.       Port[$3C9] := c[x].R;      { Set th Red value }
  28.       Port[$3C9] := c[x].g;      { Set the green value }
  29.       Port[$3C9] := c[x].b;      { Set the blue value  }
  30.     End;
  31. End;
  32.  
  33. Procedure CyclePalette(Var TPal : Palette);
  34. { Cycles the palette }
  35.  
  36. Var
  37.   Temp : RGB;
  38.  
  39. Begin
  40.   Temp := TPal[0];                 { Store first color values }
  41.   Move(TPal[1], TPal[0], 768-3);   { shift color values down one }
  42.   TPal[255] := Temp;               { store first color values in last color }
  43.   SetPalette(TPal)
  44. End;
  45.  
  46. Function GetPixel(x, y : Word) : Byte;
  47.  
  48. Begin
  49.   GetPixel := Mem[$A000:(y * 320) + x];
  50. End;
  51.  
  52.  
  53. Procedure MakePalette(Var Color : Palette);
  54. { Set up the palette to make colors look OK when cycling }
  55. { Not really too spectacular, play with this to get the desired }
  56. { palette cycling }
  57.  
  58.  
  59. Var
  60.   x : Integer;
  61.  
  62. Begin
  63.   For x := 0 to 127 do
  64.     Begin
  65.       Color[x].r := 0;
  66.       Color[x].g := (x div 2);
  67.       Color[x].b := (x div 2);
  68.     End;
  69.   For x := 127 to 255 do
  70.     Begin
  71.       Color[x].r := 0;
  72.       Color[x].g := 127 - (x div 2);
  73.       Color[x].b := 127 - (x div 2);
  74.     End;
  75. End;
  76.  
  77. Procedure PutPixel(x, y : Word; c : Byte);
  78.  
  79. Begin
  80.   Mem[$A000:(Y*320)+X] := c;
  81. End;
  82.  
  83.  
  84. Procedure NewColor(xa, ya, x, y, xb, yb : Integer);
  85. { Places a new color on the screen based on the average values }
  86. { of the surrounding pixels plus a random value                }
  87.  
  88. Const
  89.   RoughNess = 2.25;  { How rough you want the plasma to be }
  90.                      { 1.00  is very smooth                }
  91.                      { 6.00  is very rough                 }
  92.                      { Play around to get results          }
  93.  
  94. Var
  95.   color : Integer;
  96.  
  97. Begin
  98.   color := Abs(xa-xb) + abs(ya-yb);
  99.   color := ((GetPixel(xa,ya) + GetPixel(xb, yb)) Div 2) + Round((Random - 0.5)
  100.              * Color * Roughness);
  101.   if color < 1             { Make sure color stays within 1..255 range }
  102.     then Color := 1
  103.     else if color > 255    { can change 255 to any number to reserve }
  104.       then color := 255;   { for you own purposes, say 224, reserving }
  105.                            { colors 225 to 255 for yourself }
  106.                            { don't forget to change the palette cycling }
  107.                            { procedure though! }
  108.   if getpixel(x, y) = 0        { make sure the screen is clear at that point }
  109.     then PutPixel(x, y, color);
  110. End;
  111.  
  112. Procedure Iterate(x1, y1, x2, y2 : Integer);
  113. { Does the actual box seperation }
  114.  
  115. var
  116.   x, y, color : integer;
  117.  
  118. Begin
  119.   if not((x2-x1<2) and (y2-y1<2)) then
  120.     begin
  121.       x := (x1 + x2) shr 1;
  122.       y := (y1 + y2) shr 1;
  123.       NewColor(x1, y1, x , y1, x2, y1);
  124.       NewColor(x2, y1, x2, y,  x2, y2);
  125.       NewColor(x1, y2, x,  y2, x2, y2);
  126.       NewColor(x1, y1, x1, y,  x1, y2);
  127.       color := (getpixel(x1, y1) + getpixel(x2, y1) +
  128.                 getpixel(x2, y2) + getpixel(x1,y2) + 2) Shr 2;
  129.       PutPixel(x, y, color);
  130.       Iterate(x1,y1,x,y);
  131.       Iterate(x,y1,x2,y);
  132.       Iterate(x,y,x2,y2);
  133.       Iterate(x1,y,x,y2);
  134.     end;
  135. End;
  136.  
  137.  
  138. Procedure InitGraph; Assembler;
  139. { Set Mode 13h, 320x200x256 graphics mode }
  140.  
  141. Asm
  142.   MOV  AX,$0013
  143.   INT  $10
  144. End;
  145.  
  146. Begin
  147.   XRes := 320;
  148.   YRes := 200;
  149.   Initgraph;
  150.   MakePalette(D);    { set up palette to be cycled }
  151.   setpalette(D);
  152.   Randomize;
  153.  
  154.   { Put "SEED" pixels here, can be colors 1 - 255, NOT 0!!! }
  155.  
  156.   Iterate(0, 0, XRes, YRes);
  157.   repeat
  158.     cyclePalette(D);
  159.     delay(20);       { Cycling without delay is too fast! }
  160.   until keypressed;
  161.   TextMode(co80);
  162. End.